home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / psub.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  56KB  |  1,526 lines
  1. {
  2.     $Id: psub.pas,v 1.3.2.4 1998/08/22 10:23:00 florian Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl, Daniel Mantoine
  4.  
  5.     Does the parsing of the procedures/functions
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit psub;
  24. interface
  25.  
  26. uses cobjects;
  27.  
  28. procedure compile_proc_body(const proc_names:Tstringcontainer;
  29.                             make_global,parent_has_class:boolean);
  30. procedure _proc_head(options : word);
  31. procedure proc_head;
  32. procedure unter_dec;
  33.  
  34.  
  35. implementation
  36.  
  37. uses
  38.   globals,scanner,symtable,aasm,tree,pass_1,
  39.   types,hcodegen,files,verbose,systems,strings,link,import
  40. {$ifdef GDB}
  41.   ,gdb
  42. {$endif GDB}
  43.   { parser specific stuff }
  44.   ,pbase,ptconst,pdecl,pexpr,pstatmnt
  45.   { processor specific stuff }
  46. {$ifdef i386}
  47.   ,i386,cgai386,tgeni386,cgi386,aopt386
  48. {$endif}
  49. {$ifdef m68k}
  50.   ,m68k,cga68k,tgen68k,cg68k
  51. {$endif}
  52.   ;
  53.  
  54. procedure formal_parameter_list;
  55.  
  56. { handle_procvar needs the same changes }
  57.  
  58. var sc:Pstringcontainer;
  59.     s:string;
  60.     p:Pdef;
  61.     vs:Pvarsym;
  62.     hs1,hs2:string;
  63.     varspez:Tvarspez;
  64.  
  65. begin
  66.     consume(LKLAMMER);
  67.     inc(testcurobject);
  68.     repeat
  69.         if token=_VAR then
  70.             begin
  71.                 consume(_VAR);
  72.                 varspez:=vs_var;
  73.             end
  74.         else
  75.             if token=_CONST then
  76.                 begin
  77.                     consume(_CONST);
  78.                     varspez:=vs_const;
  79.                 end
  80.             else
  81.                 varspez:=vs_value;
  82.         sc:=idlist;
  83.         if token=COLON then
  84.             begin
  85.                 consume(COLON);
  86.                 { check for an open array }
  87.                 if token=_ARRAY then
  88.                     begin
  89.                         if (varspez<>vs_const) and (varspez<>vs_var) then
  90.                             begin
  91.                                 varspez:=vs_const;
  92.                                 Message(parser_e_illegal_open_parameter);
  93.                             end;
  94.                         consume(_ARRAY);
  95.                         consume(_OF);
  96.                         { define range and type of range }
  97.                         p:=new(Parraydef,init(0,-1,s32bitdef));
  98.                         { define field type }
  99.                         Parraydef(p)^.definition:=single_type(hs1);
  100.                         hs1:='array_of_'+hs1;
  101.                     end
  102.                 else
  103.                     p:=single_type(hs1);
  104.             end
  105.         else
  106.             begin
  107. {$ifndef UseNiceNames}
  108.                 hs1:='$$$';
  109. {$else UseNiceNames}
  110.                 hs1:='var';
  111. {$endif UseNiceNames}
  112.                 p:=new(Pformaldef,init);
  113.             end;
  114.         s:=sc^.get;
  115.         hs2:=aktprocsym^.definition^.mangledname;
  116.         while s<>'' do
  117.             begin
  118.                 aktprocsym^.definition^.concatdef(p,varspez);
  119. {$ifndef UseNiceNames}
  120.                 hs2:=hs2+'$'+hs1;
  121. {$else UseNiceNames}
  122.                 hs2:=hs2+tostr(length(hs1))+hs1;
  123. {$endif UseNiceNames}
  124.                 vs:=new(Pvarsym,init(s,p));
  125.                 vs^.varspez:=varspez;
  126.                 { we have to add this
  127.                   to avoid var param to be in registers !!!}
  128.                 if (varspez=vs_var) or (varspez=vs_const) and
  129.                  dont_copy_const_param(p) then
  130.                     vs^.regable:=false;
  131.                 aktprocsym^.definition^.parast^.insert(vs);
  132.                 s:=sc^.get;
  133.             end;
  134.         dispose(sc,done);
  135.         aktprocsym^.definition^.setmangledname(hs2);
  136.         if token=SEMICOLON then
  137.             consume(SEMICOLON)
  138.         else
  139.             break;
  140.     until false;
  141.     dec(testcurobject);
  142.     consume(RKLAMMER);
  143. end;
  144.  
  145. { contains the real name of a procedure as it's typed }
  146. { (the pattern isn't upper cased)                     }
  147.  
  148. var realname:stringid;
  149.  
  150. procedure _proc_head(options : word);
  151.  
  152. var sp:stringid;
  153.     pd:Pprocdef;
  154.     paramoffset:longint;
  155.     hsymtab:Psymtable;
  156.     sym:Psym;
  157.     hs:string;
  158.     overloaded_level:word;
  159.  
  160. begin
  161.     if (options and pooperator) <> 0 then
  162.         begin
  163.             sp:=overloaded_names[optoken];
  164.             realname:=sp;
  165.         end
  166.     else
  167.         begin
  168.             sp:=pattern;
  169.             realname:=orgpattern;
  170.             consume(ID);
  171.         end;
  172.  
  173.     { method ? }
  174.     if (token=POINT) and not(parse_only) then
  175.         begin
  176.             consume(POINT);
  177.             getsym(sp,true);
  178.             sym:=srsym;
  179.             { qualifier is class name ? }
  180.             if (sym^.typ<>typesym) or
  181.              (ptypesym(sym)^.definition^.deftype<>objectdef) then
  182.                Message(parser_e_class_id_expected);
  183.             { used to allow private syms to be seen }
  184.             aktobjectdef:=pobjectdef(ptypesym(sym)^.definition);
  185.             sp:=pattern;
  186.             realname:=orgpattern;
  187.             consume(ID);
  188.             procinfo._class:=pobjectdef(ptypesym(sym)^.definition);
  189.             aktprocsym:=pprocsym(procinfo._class^.publicsyms^.search(sp));
  190.             aktobjectdef:=nil;
  191.             { we solve this below }
  192.             if not(assigned(aktprocsym)) then
  193.              Message(parser_e_methode_id_expected);
  194.         end
  195.     else
  196.         begin
  197.             if not(parse_only) and
  198.              ((options and (poconstructor or podestructor))<>0) then
  199.                 Message(parser_e_constructors_always_objects);
  200.  
  201.             aktprocsym:=pprocsym(symtablestack^.search(sp));
  202.             if lexlevel=1 then
  203. {$ifdef UseNiceNames}
  204.                 hs:=procprefix+'_'+tostr(length(sp))+sp
  205. {$else UseNiceNames}
  206.                 hs:=procprefix+'_'+sp
  207. {$endif UseNiceNames}
  208.             else
  209. {$ifdef UseNiceNames}
  210.                 hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
  211. {$else UseNiceNames}
  212.                 hs:=procprefix+'_$'+sp;
  213. {$endif UseNiceNames}
  214.             if not(parse_only) then
  215.                 begin
  216.                     {The procedure we prepare for is in the implementation
  217.                      part of the unit we compile. It is also possible that we
  218.                      are compiling a program, which is also some kind of
  219.                      implementaion part.
  220.  
  221.                      We need to find out if the procedure is global. If it is
  222.                      global, it is in the global symtable.}
  223.                     if not assigned(aktprocsym) then
  224.                         begin
  225.                             {Search the procedure in the global symtable.}
  226.                             aktprocsym:=Pprocsym(search_a_symtable(sp,
  227.                              globalsymtable));
  228.  
  229.                             if assigned(aktprocsym) then
  230.                                 begin
  231.                                     {Check if it is a procedure.}
  232.                                     if typeof(aktprocsym^)<>typeof(Tprocsym) then
  233.                                      Message1(sym_e_duplicate_id,aktprocsym^.Name);
  234.  
  235.                                     {The procedure has been found. So it is
  236.                                      a global one. Set the flags to mark
  237.                                      this.}
  238.                                     procinfo.flags:=procinfo.flags or
  239.                                      pi_is_global;
  240.                                 end;
  241.                         end;
  242.                 end;
  243.         end;
  244.     { problem with procedures inside methods }
  245. {$ifndef UseNiceNames}
  246.     if assigned(procinfo._class) and (pos('_$$_',procprefix)=0) then
  247.         hs:=procprefix+'_$$_'+procinfo._class^.name^+'_'+sp;
  248. {$else UseNiceNames}
  249.     if assigned(procinfo._class) and (pos('_5Class_',procprefix)=0) then
  250.         hs:=procprefix+'_5Class_'+procinfo._class^.name^+'_'+tostr(length(sp))+sp;
  251. {$endif UseNiceNames}
  252.  
  253.     if not(assigned(aktprocsym)) then
  254.         begin
  255.             aktprocsym:=new(pprocsym,init(sp));
  256.             symtablestack^.insert(aktprocsym);
  257.         end
  258.     else
  259.         begin
  260.             { why shouldn't we overload proctected subroutines ? (FK) }
  261.             {
  262.              if assigned(procinfo._class) and ((aktprocsym^.properties and sp_protected)<>0) then
  263.                 error(cant_overload_protected);
  264.             }
  265.             if (aktprocsym^.typ=procsym) and not(aktprocsym^.definition^.forwarddef) and
  266.              (cs_tp_compatible in aktswitches) then
  267.                 Message(parser_e_procedure_overloading_is_off);
  268.         end;
  269.  
  270.     if aktprocsym^.typ<>procsym then
  271.      Message(parser_e_overloaded_no_procedure);
  272.  
  273.     pd:=new(pprocdef,init);
  274. {$ifdef GDB}
  275.     {this is just used for the name }
  276.     pd^.sym := ptypesym(aktprocsym);
  277.     if assigned(procinfo._class) then
  278.         pd^._class := procinfo._class;
  279. {$endif * GDB *}
  280.  
  281.     { set the options from the caller (podestructor or poconstructor) }
  282.     pd^.options:=pd^.options or options;
  283.  
  284.     { calculate the offset of the parameters }
  285.     paramoffset:=8;
  286.  
  287.     { calculate frame pointer offset }
  288.     if lexlevel>1 then
  289.         begin
  290.             procinfo.framepointer_offset:=paramoffset;
  291.             inc(paramoffset,4);
  292.         end;
  293.  
  294.  
  295.     if assigned (Procinfo._Class) and not(procinfo._class^.isclass) and
  296.      (
  297.       ((pd^.options and poconstructor)<>0) or
  298.       ((pd^.options and podestructor)<>0)
  299.      ) then
  300.         inc(paramoffset,4);
  301.  
  302.     { self pointer offset                              }
  303.     { self isn't pushed in nested procedure of methods }
  304.     if assigned(procinfo._class) and (lexlevel=1) then
  305.         begin
  306.             procinfo.ESI_offset:=paramoffset;
  307.             inc(paramoffset,4);
  308.         end;
  309.  
  310.     procinfo.call_offset:=paramoffset;
  311.  
  312.     pd^.parast^.datasize:=0;
  313.  
  314.     if aktprocsym^.typ=procsym then
  315.        pd^.nextoverloaded:=aktprocsym^.definition
  316.     else
  317.        pd^.nextoverloaded:=nil;
  318.     aktprocsym^.definition:=pd;
  319.     aktprocsym^.definition^.setmangledname(hs);
  320.     if not(parse_only) then
  321.         procprefix:=hs;
  322.     if assigned(pd^.nextoverloaded) and (pd^.nextoverloaded^.owner=
  323.      symtablestack) then
  324.         begin
  325.             { we need another procprefix !!! }
  326.             overloaded_level:=1;
  327.             { count, but only those in the same unit !!}
  328.             while assigned(pd^.nextoverloaded) and
  329.              (pd^.nextoverloaded^.owner=symtablestack) do
  330.                 begin
  331.                    inc(overloaded_level);
  332.                    pd:=pd^.nextoverloaded;
  333.                 end;
  334.             procprefix:=hs+'$'+tostr(overloaded_level)+'$';
  335.         end;
  336.     if token=LKLAMMER then
  337.         formal_parameter_list;
  338.     if (options and pooperator) <> 0 then
  339.         begin
  340.             if overloaded_operators[optoken]=nil then
  341.                 overloaded_operators[optoken]:=aktprocsym;
  342.         end
  343. end;
  344.  
  345. procedure proc_head;
  346.  
  347. var hs:string;
  348.     isclassmethod:boolean;
  349.  
  350. begin
  351.     { read class method }
  352.     if token=_CLASS then
  353.         begin
  354.             consume(_CLASS);
  355.             isclassmethod:=true;
  356.         end
  357.     else
  358.         isclassmethod:=false;
  359.  
  360.     if token=_FUNCTION then
  361.         begin
  362.             consume(_FUNCTION);
  363.             _proc_head(0);
  364.             if token<>COLON then
  365.                 begin
  366.                    consume(COLON);
  367.                    {while token<>SEMICOLON do
  368.                      consume(token); }
  369.                    consume_all_until(SEMICOLON);
  370.                 end
  371.             else
  372.                 begin
  373.                    consume(COLON);
  374.                    aktprocsym^.definition^.retdef:=single_type(hs);
  375.                 end;
  376.         end
  377.     else
  378.         if token=_PROCEDURE then
  379.             begin
  380.                 consume(_PROCEDURE);
  381.                 _proc_head(0);
  382.                 aktprocsym^.definition^.retdef:=voiddef;
  383.             end
  384.         else
  385.             if token=_CONSTRUCTOR then
  386.                 begin
  387.                     consume(_CONSTRUCTOR);
  388.                     _proc_head(poconstructor);
  389.  
  390.                     if (procinfo._class^.options and oois_class)<>0 then
  391.                         begin
  392.                             {CLASS constructors return the created instance }
  393.                             aktprocsym^.definition^.retdef:=procinfo._class;
  394.                         end
  395.                     else
  396.                         begin
  397.                             {OBJECT constructors return a boolean }
  398. {$IfDef GDB}
  399.                             {GDB doesn't like unnamed types !}
  400.                             aktprocsym^.definition^.retdef:=
  401.                             globaldef('boolean');
  402. {$Else * GDB *}
  403.                             aktprocsym^.definition^.retdef:=
  404.                              new(porddef,init(bool8bit,0,1));
  405.  
  406. {$Endif * GDB *}
  407.                         end;
  408.                 end
  409.         else
  410.             if token=_DESTRUCTOR then
  411.                 begin
  412.                     consume(_DESTRUCTOR);
  413.                     _proc_head(podestructor);
  414.                     aktprocsym^.definition^.retdef:=voiddef;
  415.                 end
  416.             else
  417.                 if token=_OPERATOR then
  418.                     begin
  419.                         { internalerror(110); }
  420.                         consume(_OPERATOR);
  421.                         if not(token in [PLUS..last_overloaded]) then
  422.                          Message(parser_e_overload_operator_failed);
  423.                         optoken:=token;
  424.                         consume(token);
  425.                         procinfo.flags:=procinfo.flags or pi_operator;
  426.                         _proc_head(pooperator);
  427.                         if token<>ID then
  428.                             consume(ID)
  429.                         else
  430.                             begin
  431.                                 opsym:=new(pvarsym,init(pattern,voiddef));
  432.                                 consume(ID);
  433.                             end;
  434.                         if token<>COLON then
  435.                             begin
  436.                                consume(COLON);
  437.                                { while token<>SEMICOLON do
  438.                                  consume(token); }
  439.                                consume_all_until(SEMICOLON);
  440.                             end
  441.                         else
  442.                             begin
  443.                                consume(COLON);
  444.                                aktprocsym^.definition^.retdef:=
  445.                                 single_type(hs);
  446.                                if (optoken in [EQUAL,GT,LT,GTE,LTE]) and
  447.                                 ((aktprocsym^.definition^.retdef^.deftype<>
  448.                                 orddef) or (porddef(aktprocsym^.definition^.
  449.                                 retdef)^.typ<>bool8bit)) then
  450.                                    Message(parser_e_comparative_operator_return_boolean);
  451.                                 if ret_in_param(aktprocsym^.definition^.
  452.                                  retdef) then
  453.                                     pprocdef(aktprocsym^.definition)^.
  454.                                      parast^.insert(opsym)
  455.                                 else
  456.                                     pprocdef(aktprocsym^.definition)^.
  457.                                      localst^.insert(opsym);
  458.                                 opsym^.definition:=aktprocsym^.definition^.
  459.                                  retdef;
  460.                             end;
  461.                     end;
  462.     if isclassmethod then
  463.        aktprocsym^.definition^.options:=aktprocsym^.definition^.options
  464.         or poclassmethod;
  465.     consume(SEMICOLON);
  466. end;
  467.  
  468. {****************************************************************************
  469.  
  470.                         Procedure directive handlers:
  471.  
  472. ****************************************************************************}
  473.  
  474. {$ifdef tp}
  475.   {$F+}
  476. {$endif}
  477.  
  478. procedure pd_far(const procnames:Tstringcontainer);
  479.  
  480. begin
  481.   Message(parser_w_proc_far_ignored);
  482. end;
  483.  
  484. procedure pd_near(const procnames:Tstringcontainer);
  485.  
  486. begin
  487.   Message(parser_w_proc_far_ignored);
  488. end;
  489.  
  490. procedure pd_export(const procnames:Tstringcontainer);
  491.  
  492. begin
  493.     procnames.insert(realname);
  494.     procinfo.exported:=true;
  495.     if gendeffile then
  496.         writeln(deffile,#9+aktprocsym^.definition^.mangledname);
  497.     if assigned(procinfo._class) then
  498.       Message(parser_e_methods_dont_be_export);
  499.     if lexlevel<>1 then
  500.       Message(parser_e_dont_nest_export);
  501. end;
  502.  
  503. procedure pd_inline(const procnames:Tstringcontainer);
  504.  
  505. begin
  506.     if not(support_inline) then
  507.      Message(parser_e_proc_inline_not_supported);
  508. end;
  509.  
  510. procedure pd_forward(const procnames:Tstringcontainer);
  511.  
  512. begin
  513.     aktprocsym^.definition^.forwarddef:=true;
  514.     aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
  515. end;
  516.  
  517. procedure pd_alias(const procnames:Tstringcontainer);
  518.  
  519. begin
  520.     consume(COLON);
  521.     procnames.insert(pattern);
  522.     if token=CCHAR then
  523.         consume(CCHAR)
  524.     else
  525.         consume(CSTRING);
  526. end;
  527.  
  528. procedure pd_intern(const procnames:Tstringcontainer);
  529.  
  530. begin
  531.     consume(COLON);
  532.     aktprocsym^.definition^.extnumber:=get_intconst;
  533. end;
  534.  
  535. procedure pd_system(const procnames:Tstringcontainer);
  536.  
  537. begin
  538.     aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
  539.      poclearstack;
  540.     aktprocsym^.definition^.setmangledname(realname);
  541. end;
  542.  
  543. procedure pd_c_import(const procnames:Tstringcontainer);
  544.  
  545. begin
  546.     aktprocsym^.definition^.options:=
  547.       aktprocsym^.definition^.options or poclearstack;
  548.     aktprocsym^.definition^.setmangledname(target_info.Cprefix+realname);
  549. end;
  550.  
  551. procedure pd_lefrig(const procnames:Tstringcontainer);
  552. begin
  553.   Message(parser_f_unsupported_feature);
  554. end;
  555.  
  556. procedure pd_syscall(const procnames:Tstringcontainer);
  557.  
  558.   begin
  559.      aktprocsym^.definition^.options:=
  560.        aktprocsym^.definition^.options or poclearstack;
  561.      aktprocsym^.definition^.extnumber:=get_intconst;
  562.   end;
  563.  
  564. procedure pd_extern(const procnames:Tstringcontainer);
  565.  
  566.   var
  567.      { If import_dll=nil the procedure is assumed to be in another
  568.        object file. In that object file it should have the name to
  569.        which import_name is pointing to. Otherwise, the procedure is
  570.        assumed to be in the DLL to which import_dll is pointing to. In
  571.        that case either import_nr<>0 or import_name<>nil is true, so
  572.        the procedure is either imported by number or by name. (DM)}
  573.      import_dll,import_name : string;
  574.      import_nr : word;
  575.  
  576. begin
  577.     aktprocsym^.definition^.forwarddef:=false;
  578.  
  579.     {If the procedure should be imported from a DLL, a constant string
  580.      follows.}
  581.     { This isn't really correct, an contant string expression follows (FK) }
  582.     { so we check if an semicolon follows, else a string constant have to  }
  583.     { follow (FK)                                                          }
  584.  
  585.     { The following implementation is TP syntax, Daniel !!!! }
  586.  
  587.     import_nr:=0;
  588.     import_name:='';
  589.     if not(token=SEMICOLON) and not((token=ID) and (pattern='NAME')) then
  590.        begin
  591.            import_dll:=get_stringconst;
  592.            if (token=ID) and (pattern='NAME') then
  593.                begin
  594.                    consume(ID);
  595.                    import_name:=get_stringconst;
  596.                end;
  597.            if (token=ID) and (pattern='INDEX') then
  598.                begin
  599.                    {After the word index follows the index number in the DLL.}
  600.                    consume(ID);
  601.                    import_nr:=get_intconst;
  602.                end;
  603.            if (import_nr=0) and (import_name='') then
  604.              Message(unit_d_ppu_file_too_short);
  605.            if not(current_module^.uses_imports) then
  606.              begin
  607.                 current_module^.uses_imports:=true;
  608.                 importlib^.preparelib(current_module^.unitname^);
  609.              end;
  610.            importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name)
  611.        end
  612.     else
  613.         begin
  614.            if (token=ID) and (pattern='NAME') then
  615.              begin
  616.                 consume(ID);
  617.                 aktprocsym^.definition^.setmangledname(get_stringconst);
  618.              end
  619.            else
  620.              { external shouldn't override the cdecl/system name }
  621.              if (aktprocsym^.definition^.options and poclearstack)=0 then
  622.                aktprocsym^.definition^.setmangledname(aktprocsym^.name);
  623.         end;
  624. end;
  625.  
  626. {$ifdef tp}
  627.   {$F-}
  628. {$endif}
  629.  
  630. procedure parse_proc_direc(const naam:string;const proc_names:Tstringcontainer;
  631.                            var body,make_global:boolean);
  632.  
  633. {Parse a procedure directive. The parsing of procedure directives has
  634.  been removed from unter_dec, to improve sourcecode readability.}
  635.  
  636. type    pd_handler=procedure(const procnames:Tstringcontainer);
  637.         proc_dir_rec=record
  638.             naam:string[15];        {15 letters should be enough.}
  639.             handler:pd_handler;     {Handler.}
  640.             flag:longint;              {Procedure flag. May be zero.}
  641.             body,                   {Parse a procedure body?}
  642.             global:boolean;         {Must the procedure be global?}
  643.             mut_excl:longint;          {List of mutually exclusive flags.}
  644.         end;
  645.  
  646. const   {Should contain the number of procedure directives we support.}
  647.         num_proc_directives=17;
  648.         {Should contain the largest power of 2 lower than
  649.          num_proc_directives, the int value of the 2-log of it. Cannot be
  650.          calculated using an constant expression, as far as I know.}
  651.         num_proc_directives_2log=8;
  652.  
  653. {$IFDEF TP}
  654.         {Cool TP syntax...}
  655.         proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
  656.          ((naam:'ALIAS'     ;handler:pd_alias   ;flag:0            ;body:true ;global:false;
  657.             mut_excl:poinline+poexternal),
  658.           (naam:'ASSEMBLER' ;handler:nil        ;flag:poassembler  ;body:true;global:false;
  659.             mut_excl:poinline+pointernproc+poexternal),
  660.           {
  661.           (naam:'C'         ;handler:pd_c_import;flag:poclearstack ;body:false;global:false;
  662.             mut_excl:poleftright+poinline+poassembler+pointernproc),
  663.           }
  664.           (naam:'CDECL'         ;handler:pd_c_import;flag:poclearstack;body:true;global:false;
  665.             mut_excl:poleftright+poinline+poassembler+pointernproc),
  666.           (naam:'EXPORT'    ;handler:pd_export  ;flag:poexports    ;body:true ;global:true ;
  667.             mut_excl:poexternal+poinline+pointernproc+pointerrupt),
  668.           (naam:'EXTERNAL'  ;handler:pd_extern  ;flag:poexternal   ;body:false;global:false;
  669.             mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler),
  670.           (naam:'FAR'       ;handler:pd_far     ;flag:0            ;body:true ;global:false;
  671.             mut_excl:pointernproc),
  672.           (naam:'FORWARD'   ;handler:pd_forward ;flag:0            ;body:false;global:false;
  673.             mut_excl:pointernproc),
  674.           (naam:'INLINE'    ;handler:pd_inline  ;flag:poinline     ;body:true ;global:false;
  675.             mut_excl:poexports+poexternal+pointernproc+pointerrupt+poassembler+poconstructor+podestructor+pooperator),
  676.           (naam:'INTERNPROC';handler:pd_intern  ;flag:pointernproc ;body:false;global:false;
  677.             mut_excl:poexports+poexternal+pointerrupt+poassembler+poclearstack+poleftright+poiocheck+
  678.                      poconstructor+podestructor+pooperator),
  679.           (naam:'INTERRUPT' ;handler:nil        ;flag:pointerrupt  ;body:true ;global:false;
  680.             mut_excl:pointernproc+poclearstack+poleftright+poinline+poconstructor+podestructor+pooperator),
  681.           (naam:'IOCHECK'   ;handler:nil        ;flag:poiocheck    ;body:true ;global:false;
  682.             mut_excl:pointernproc+poexternal),
  683.           (naam:'NEAR'      ;handler:pd_near    ;flag:0            ;body:true ;global:false;
  684.             mut_excl:pointernproc),
  685.           {Use "Pascal" calling conventions, parameters from left to right. Combine
  686.            with 'EXTERNAL' when it is external, the procedure compiled
  687.            assumes left/right pushes. Currently recognised but not supported!}
  688.           (naam:'PASCAL'    ;handler:pd_lefrig  ;flag:poleftright  ;body:true ;global:false;mut_excl:pointernproc),
  689.           {Equal to 'SYSTEM', but doesn't assume the procedure is external,
  690.            so the compiled procedure assumes it doesn't need to clear the
  691.            stack. Can also be combined with external, in that case it is completely
  692.            equal to 'SYSTEM'.}
  693.           (naam:'POPSTACK'  ;handler:nil        ;flag:poclearstack ;body:true ;global:false;
  694.             mut_excl:poinline+pointernproc+poassembler),
  695.           (naam:'PUBLIC'    ;handler:nil        ;flag:0            ;body:true ;global:true ;
  696.             mut_excl:pointernproc+poinline),
  697.           (naam:'SYSCALL'    ;handler:pd_syscall  ;flag:popalmossyscall;body:false;global:false;
  698.             mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler),
  699.           (naam:'SYSTEM'    ;handler:pd_system  ;flag:poclearstack ;body:false;global:false;
  700.             mut_excl:poleftright+poinline+poassembler+pointernproc));
  701. {$ELSE}
  702.         proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
  703.          ((naam:'ALIAS'     ;handler:@pd_alias   ;flag:0            ;body:true ;global:false;
  704.             mut_excl:poinline+poexternal),
  705.           (naam:'ASSEMBLER' ;handler:nil         ;flag:poassembler  ;body:true ;global:false;
  706.             mut_excl:poinline+pointernproc+poexternal),
  707.           {
  708.           (naam:'C'         ;handler:@pd_c_import;flag:poclearstack ;body:false;global:false;
  709.             mut_excl:poleftright+poinline+poassembler+pointernproc),
  710.           }
  711.           (naam:'CDECL'         ;handler:@pd_c_import;flag:poclearstack;body:true;global:false;
  712.             mut_excl:poleftright+poinline+poassembler+pointernproc),
  713.           (naam:'EXPORT'    ;handler:@pd_export  ;flag:poexports    ;body:true ;global:true ;
  714.             mut_excl:poexternal+poinline+pointernproc+pointerrupt),
  715.           (naam:'EXTERNAL'  ;handler:@pd_extern  ;flag:poexternal   ;body:false;global:false;
  716.             mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler),
  717.           (naam:'FAR'       ;handler:@pd_far     ;flag:0            ;body:true ;global:false;
  718.             mut_excl:pointernproc),
  719.           (naam:'FORWARD'   ;handler:@pd_forward ;flag:0            ;body:false;global:false;
  720.             mut_excl:pointernproc),
  721.           (naam:'INLINE'    ;handler:@pd_inline  ;flag:poinline     ;body:true ;global:false;
  722.             mut_excl:poexports+poexternal+pointernproc+pointerrupt+poassembler+poconstructor+podestructor+pooperator),
  723.           (naam:'INTERNPROC';handler:@pd_intern  ;flag:pointernproc ;body:false;global:false;
  724.             mut_excl:poexports+poexternal+pointerrupt+poassembler+poclearstack+poleftright+poiocheck+
  725.                      poconstructor+podestructor+pooperator),
  726.           (naam:'INTERRUPT' ;handler:nil         ;flag:pointerrupt  ;body:true ;global:false;
  727.             mut_excl:pointernproc+poclearstack+poleftright+poinline+poconstructor+podestructor+pooperator),
  728.           (naam:'IOCHECK'   ;handler:nil        ;flag:poiocheck    ;body:true ;global:false;
  729.             mut_excl:pointernproc+poexternal),
  730.           (naam:'NEAR'      ;handler:@pd_near    ;flag:0            ;body:true ;global:false;
  731.             mut_excl:pointernproc),
  732.           {Use "Pascal" calling conventions, parameters from left to right. Combine
  733.            with 'EXTERNAL' when it is external, the procedure compiled
  734.            assumes left/right pushes. Currently recognised but not supported!}
  735.           (naam:'PASCAL'    ;handler:@pd_lefrig  ;flag:poleftright  ;body:true ;global:false;
  736.             mut_excl:pointernproc),
  737.           {Equal to 'SYSTEM', but doesn't assume the procedure is external,
  738.            so the compiled procedure assumes it doesn't need to clear the
  739.            stack. Can also be combined with external, in that case it is completely
  740.            equal to 'SYSTEM'.}
  741.           (naam:'POPSTACK'  ;handler:nil         ;flag:poclearstack ;body:true ;global:false;
  742.             mut_excl:poinline+pointernproc+poassembler),
  743.           (naam:'PUBLIC'    ;handler:nil         ;flag:0            ;body:true ;global:true ;
  744.             mut_excl:pointernproc+poinline),
  745.           (naam:'SYSCALL'    ;handler:@pd_syscall  ;flag:popalmossyscall ;body:false;global:false;
  746.             mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler),
  747.           (naam:'SYSTEM'    ;handler:@pd_system  ;flag:poclearstack ;body:false;global:false;
  748.             mut_excl:poleftright+poinline+poassembler+pointernproc));
  749. {$ENDIF TP}
  750.  
  751. var p,w:word;
  752.     s:boolean;
  753.  
  754. begin
  755.     s:=aktprocsym^.definition^.options and poassembler<>0;
  756.     {15 letters should be enough, but give protection if someone tries a
  757.      longer one. Also check if the flag is already used.}
  758.     if (length(naam)>15) then
  759.         begin
  760.           Message1(parser_w_unknown_proc_directive_ignored,naam);
  761.           exit;
  762.         end;
  763.  
  764.     {Search the procedure directive in the array. We shoot with a bazooka
  765.      on a bug, that is, we release a binary search.}
  766.     w:=num_proc_directives_2log;
  767.     p:=1;
  768.     while w<>0 do
  769.         begin
  770.             if proc_direcdata[p+w].naam<=naam then
  771.                 p:=p+w;
  772.             w:=w shr 1;
  773.         end;
  774.  
  775.     {Check if the procedure directive is known.}
  776.     if naam<>proc_direcdata[p].naam then
  777.      begin
  778.        Message1(parser_w_unknown_proc_directive_ignored,naam);
  779.        exit;
  780.      end;
  781.  
  782.     {Check if the flag is alread used.}
  783.     if aktprocsym^.definition^.options and (proc_direcdata[p].flag+
  784.      proc_direcdata[p].mut_excl)<>0 then
  785.         {The touch of perfection: Determine which error message is
  786.          more usefull.}
  787.         if s then
  788.             consume(_ASM)
  789.         else
  790.             consume(_BEGIN);
  791.  
  792.     {Return the correct body and make_global parameters.}
  793.     body:=proc_direcdata[p].body;
  794.     make_global:=proc_direcdata[p].global;
  795.  
  796.     {Add the correct flag.}
  797.     aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
  798.      proc_direcdata[p].flag;
  799.  
  800.     {Call the handler.}
  801. {$IFDEF TP}
  802.     if @proc_direcdata[p].handler<>nil then
  803.         proc_direcdata[p].handler(proc_names);
  804. {$ELSE}
  805.     if pointer(proc_direcdata[p].handler)<>nil then
  806.         proc_direcdata[p].handler(proc_names);
  807. {$ENDIF TP}
  808. end;
  809.  
  810. {***************************************************************************}
  811.  
  812. function check_identical:boolean;
  813.  
  814. { Search for idendical definitions,
  815.   if there is a forward, then kill this.
  816.  
  817.   Returns the result of the forward check.
  818.  
  819.   Removed from unter_dec to keep the source readable.}
  820.  
  821. const   {List of procedure options that affect the procedure type.}
  822.         pt_params=poconstructor+podestructor+pooperator;
  823.  
  824. var hd,pd:Pprocdef;
  825.     ad,fd:psym;
  826.  
  827. begin
  828.     check_identical:=false;
  829.     pd:=aktprocsym^.definition;
  830.     while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
  831.         begin
  832.             if (cs_tp_compatible in aktswitches) or
  833.              equal_paras(aktprocsym^.definition^.para1,
  834.              pd^.nextoverloaded^.para1) then
  835.                 begin
  836.                     if pd^.nextoverloaded^.forwarddef then
  837.                         { remove the forward definition }
  838.                         { but don't delete it,          }
  839.                         { the symtable is the owner !!  }
  840.                         begin
  841.                             hd:=pd^.nextoverloaded;
  842.                             {Check if the procedure type (constructor/
  843.                              destructor/etc. and return type are correct.}
  844.                             if ((hd^.options and pt_params)<>(aktprocsym^.
  845.                              definition^.options and pt_params)) or
  846.                              not(is_equal(hd^.retdef,aktprocsym^.
  847.                              definition^.retdef)) then
  848.                                Message1(parser_e_header_dont_match_forward,'');
  849.  
  850.                             { change the name }
  851.                             { this should have been set already, no ? }
  852.                             if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
  853.                                 begin
  854.                                 if (aktprocsym^.definition^.options and poexternal)=0 then
  855.                                     Message(parser_n_interface_name_diff_implementation_name);
  856.                                   hd^.setmangledname(aktprocsym^.definition^.mangledname);
  857.                                 end
  858.                              else
  859.                                begin
  860.                                   { If mangled names are equal, therefore    }
  861.                                   { they have the same number of parameters  }
  862.                                   { Therefore we can check the name of these }
  863.                                   { parameters...                            }
  864.                                   ad:=hd^.parast^.wurzel;
  865.                                   fd:=aktprocsym^.definition^.parast^.wurzel;
  866.                                   if assigned(ad) and assigned(fd) then
  867.                                   begin
  868.                                     while assigned(ad) and assigned(fd) do
  869.                                       begin
  870.                                         if ad^.name<>fd^.name then
  871.                                          begin
  872.                                            Message1(parser_e_header_dont_match_forward,ad^.name);
  873.                                            break;
  874.                                          end;
  875.                                          { it is impossible to have a nil pointer }
  876.                                          { for only one parameter - since they    }
  877.                                          { have the same number of parameters.    }
  878.                                          { Left = next parameter.                 }
  879.                                          ad:=ad^.left;
  880.                                          fd:=fd^.left;
  881.                                       end;
  882.                                   end;
  883.                                end;
  884.  
  885.                             { also the call_offset }
  886.                             hd^.parast^.call_offset:=aktprocsym^.definition^.
  887.                              parast^.call_offset;
  888.  
  889.                             { pd^.nextoverloaded aus der Liste an den Anfang }
  890.                             { und aktprocsym^.definition aushaengen }
  891.                             pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
  892.                             hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
  893.                             {Alert! All fields of aktprocsym^.definition
  894.                              that are modified by the procdir handlers
  895.                              must be copied here!.}
  896.                             hd^.forwarddef:=false;
  897.                             if (hd^.options and pt_params)<>(aktprocsym^.
  898.                              definition^.options and pt_params) then
  899.                              Message(parser_e_syntax_error)
  900.                             else
  901.                                 hd^.options:=hd^.options or aktprocsym^.definition^.options;
  902.                             if aktprocsym^.definition^.extnumber=-1 then
  903.                                 aktprocsym^.definition^.extnumber:=hd^.extnumber
  904.                             else
  905.                                 if hd^.extnumber=-1 then
  906.                                     hd^.extnumber:=aktprocsym^.definition^.extnumber;
  907.                             aktprocsym^.definition:=hd;
  908.                             check_identical:=true;
  909.                         end
  910.                     else
  911.                         { abstract methods aren't forward defined, but this }
  912.                         { needs another error message                       }
  913.                         if (pd^.nextoverloaded^.options and poabstractmethod)=0 then
  914.                             Message(parser_e_overloaded_have_same_parameters)
  915.                         else
  916.                             Message(parser_e_abstract_no_definition);
  917.                     break;
  918.                 end;
  919.             pd:=pd^.nextoverloaded;
  920.         end;
  921. end;
  922.  
  923. procedure compile_proc_body(const proc_names:Tstringcontainer;
  924.                             make_global,parent_has_class:boolean);
  925.  
  926. {Compile the body of a procedure.}
  927.  
  928. var oldexitlabel,oldexit2label,oldquickexitlabel:Plabel;
  929.     _class:Pobjectdef;
  930.     { switches can change inside the procedure }
  931.     entryswitches, exitswitches : tcswitches;
  932.     { code for the subroutine as tree }
  933.     code:Ptree;
  934.     { Gr”áe des lokalen Stackframes }
  935.     stackframe:longint;
  936.     { true wenn kein Stackframe erforderlich ist }
  937.     nostackframe:boolean;
  938.     { number of bytes which have to be cleared by RET }
  939.     parasize:longint;
  940. {$ifdef GDB}
  941.     entrystack,exitstack, storestack:pinputfile;
  942.     entryline, exitline, storeline:longint;
  943. {$endif GDB}
  944.  
  945. begin
  946.     oldexitlabel:=aktexitlabel;
  947.     oldexit2label:=aktexit2label;
  948.     oldquickexitlabel:=quickexitlabel;
  949.     getlabel(aktexitlabel);
  950.     getlabel(aktexit2label);
  951.  
  952.     { calculate the lexical level }
  953.     inc(lexlevel);
  954.  
  955.     { enter allows only (?) 31 levels }
  956.     { I think we don't need more      }
  957.     if lexlevel>32 then
  958.      Message(parser_e_too_much_lexlevel);
  959.  
  960.     { reset break and continue labels }
  961.     in_except_block:=false;
  962.     aktbreaklabel:=nil;
  963.     aktcontinuelabel:=nil;
  964.  
  965.     { exit for fail in constructors }
  966.     if (aktprocsym^.definition^.options and poconstructor)<>0 then
  967.         getlabel(quickexitlabel);
  968.  
  969.     { insert symtables for the class, by only if it is no }
  970.     { nested function                                     }
  971.     if assigned(procinfo._class) and
  972.      not(parent_has_class) then
  973.         begin
  974.             _class:=procinfo._class;
  975.             while assigned(_class) do
  976.                 begin
  977.                     _class^.publicsyms^.next:=symtablestack;
  978.                     symtablestack:=_class^.publicsyms;
  979.                     _class:=_class^.childof;
  980.                 end;
  981.         end;
  982.  
  983.     { insert symbol tables }
  984.     { and set the lexical level }
  985.     { not for global }
  986.     { if lexlevel>1 then }
  987.       begin
  988.          aktprocsym^.definition^.parast^.next:=symtablestack;
  989.          symtablestack:=aktprocsym^.definition^.parast;
  990.      {***RESTRUCT}
  991.          symtablestack^.symtablelevel:=lexlevel;
  992.          aktprocsym^.definition^.localst^.next:=symtablestack;
  993.          symtablestack:=aktprocsym^.definition^.localst;
  994.          symtablestack^.symtablelevel:=lexlevel;
  995.       end;
  996. {***}
  997.  
  998.     { constant symbols are inserted in this symboltable }
  999.     constsymtable:=symtablestack;
  1000.  
  1001.     { reset the temporary memory }
  1002.     cleartempgen;
  1003.  
  1004.     { no registers are used }
  1005.     usedinproc:=0;
  1006. {$ifdef GDB}
  1007.     entrystack:=current_module^.current_inputfile;
  1008.     entryline:=current_module^.current_inputfile^.line_no;
  1009. {$endif * GDB *}
  1010.  
  1011.     entryswitches:=aktswitches;
  1012.  
  1013.     { parse the code ... }
  1014.     if (aktprocsym^.definition^.options and poassembler)<> 0 then
  1015.         code:=assembler_block
  1016.     else
  1017.         code:=block(false);
  1018.     exitswitches:=aktswitches;
  1019.  
  1020.     {When we are called to compile the body of a unit, aktprocsym should
  1021.      point to the unit initialization. If the unit has no initialization,
  1022.      aktprocsym=nil. But in that case code=nil. hus we should check for
  1023.      code=nil, when we use aktprocsym.}
  1024.  
  1025.     { set the framepointer to esp for assembler functions }
  1026.     { but only if the are no local variables NOR any      }
  1027.     { parameters!                                         }
  1028.     if assigned(code) and
  1029.      ((aktprocsym^.definition^.options and poassembler)<>0) and
  1030.      (aktprocsym^.definition^.parast^.datasize=0) and
  1031.      (aktprocsym^.definition^.localst^.datasize=0) then
  1032.         begin
  1033. {***IMPROVED}
  1034. {The stack_pointer constant is declared in the procecessor specific unit,
  1035.  such as i386.pas.}
  1036.             procinfo.framepointer:=stack_pointer;
  1037. {***}
  1038.             { set the right value for parameters }
  1039.             dec(aktprocsym^.definition^.parast^.call_offset,4);
  1040.             dec(procinfo.call_offset,4);
  1041.         end;
  1042. {$ifdef GDB}
  1043.     exitstack := current_module^.current_inputfile;
  1044.     exitline := current_module^.current_inputfile^.line_no;
  1045.     setfirsttemp(procinfo.firsttemp);
  1046. {$endif * GDB *}
  1047.  
  1048.     { ... and generate assembler }
  1049.     { but set the right switches for entry !! }
  1050.     aktswitches:=entryswitches;
  1051.  
  1052.     if assigned(code) then
  1053.         generatecode(code);
  1054.  
  1055.     { set switches to status at end of procedure }
  1056.     aktswitches:=exitswitches;
  1057.  
  1058.     if assigned(code) then
  1059.         begin
  1060.             { inline procedure ?? }
  1061.             if (aktprocsym^.definition^.options and poinline)=0 then
  1062.                 { ...no, the code isn't needed }
  1063.                 disposetree(code)
  1064.             else
  1065.                 aktprocsym^.definition^.code:=code;
  1066.         end;
  1067.  
  1068.     { dec(lexlevel); moved to the end (PM) }
  1069. {$ifdef GDB}
  1070.     storeline := entrystack^.line_no;
  1071.     entrystack^.line_no := entryline;
  1072.     storestack := current_module^.current_inputfile;
  1073.     current_module^.current_inputfile := entrystack;
  1074. {$endif * GDB *}
  1075.  
  1076.     if assigned(code) then
  1077.         begin
  1078.             { the procedure is no defined }
  1079.             aktprocsym^.definition^.forwarddef:=false;
  1080.             aktprocsym^.definition^.usedregisters:=usedinproc;
  1081.         end;
  1082.  
  1083.     stackframe:=gettempsize;
  1084. {$ifdef GDB}
  1085.     { only now we can remove the temps }
  1086.     resettempgen;
  1087.  
  1088.     if assigned(code) then
  1089.         genentrycode(proc_names,make_global,stackframe,parasize,
  1090.          nostackframe);
  1091.  
  1092.     entrystack^.line_no := storeline;
  1093.     storeline := exitstack^.line_no;
  1094.     exitstack^.line_no := exitline;
  1095.     current_module^.current_inputfile := exitstack;
  1096. {$endif * GDB *}
  1097.  
  1098.     if assigned(code) then
  1099.         begin
  1100.             genexitcode(parasize,nostackframe);
  1101.  
  1102.             procinfo.aktproccode^.insertlist(procinfo.aktentrycode);
  1103.             procinfo.aktproccode^.concatlist(procinfo.aktexitcode);
  1104. {$ifdef i386}
  1105.             if (cs_optimize in aktswitches) and
  1106.             { no asm block allowed }
  1107.               ((procinfo.flags and pi_uses_asm)=0)  then
  1108.                 peepholeopt(procinfo.aktproccode);
  1109. {$endif}
  1110. {$ifdef MAKELIB}
  1111.             { start a new file }
  1112.             { could be done at lexlevel 1 only }
  1113.             { but to separate underprocs will permit to }
  1114.             { discard unused ones }
  1115.             codesegment^.concat(new(pai_cut,init));
  1116. {$endif MAKELIB}
  1117.             codesegment^.concatlist(procinfo.aktproccode);
  1118.         end;
  1119.  
  1120.     { ... remove symbol tables }
  1121.     symtablestack:=symtablestack^.next^.next;
  1122.  
  1123.     { ... check for unused symbols      }
  1124.     { but only if there is no asm block }
  1125.     if assigned(code) and not((procinfo.flags and pi_uses_asm)<>0) then
  1126.         begin
  1127.             aktprocsym^.definition^.localst^.allsymbolsused;
  1128.             aktprocsym^.definition^.parast^.allsymbolsused;
  1129.         end;
  1130.  
  1131.     { the local symtables can be deleted, but the parast }
  1132.     { doesn't, (checking definitons when calling a       }
  1133.     { function                                           }
  1134.     if assigned(code) then
  1135.         begin
  1136.             dispose(aktprocsym^.definition^.localst,done);
  1137.             aktprocsym^.definition^.localst:=nil;
  1138.         end;
  1139.  
  1140.     { remove class member symbol tables }
  1141.     while symtablestack^.symtabletype=objectsymtable do
  1142.         symtablestack:=symtablestack^.next;
  1143.  
  1144. {$ifdef GDB}
  1145.     current_module^.current_inputfile := storestack;
  1146.     exitstack^.line_no := storeline;
  1147. {$endif GDB}
  1148.     dec(lexlevel);
  1149.     aktexitlabel:=oldexitlabel;
  1150.     aktexit2label:=oldexit2label;
  1151.     quickexitlabel:=oldquickexitlabel;
  1152. end;
  1153.  
  1154. procedure parse_proc_directives(Anames:Pstringcontainer;
  1155.                                 var make_global,parse_body:boolean);
  1156.  
  1157. {Parse the procedure directives. Unlike the original code, it does not matter
  1158.  if procedure directives are written using ;procdir; or ['procdir'] syntax.
  1159.  I did this, because I do not see any logic in the separation.}
  1160.  
  1161. var naam:string;
  1162.     global,body:boolean;
  1163.  
  1164. begin
  1165.     while token in [ID,LECKKLAMMER] do
  1166.         begin
  1167.             if token=LECKKLAMMER then
  1168.                 begin
  1169.                     consume(LECKKLAMMER);
  1170.                     repeat
  1171.                         naam:=pattern;
  1172.                         consume(ID);
  1173.                         parse_proc_direc(naam,Anames^,body,global);
  1174.                         if not body then
  1175.                             parse_body:=false;
  1176.                         if global then
  1177.                             make_global:=true;
  1178.                         if token=COMMA then
  1179.                             consume(COMMA)
  1180.                         else
  1181.                             break;
  1182.                     until false;
  1183.                     consume(RECKKLAMMER);
  1184.                 end
  1185.             else
  1186.                 begin
  1187.                     naam:=pattern;
  1188.                     consume(ID);
  1189.                     parse_proc_direc(naam,Anames^,body,make_global);
  1190.                     if not body then
  1191.                         parse_body:=false;
  1192.                 end;
  1193.             {A procedure directive is always followed by a
  1194.              semicolon.}
  1195.             consume(SEMICOLON);
  1196.         end;
  1197. end;
  1198.  
  1199. procedure unter_dec;
  1200.  
  1201. {Parses the procedure directives, then parses the procedure body, then
  1202.  generates the code for it.}
  1203.  
  1204. {******This procedure has been dramatically rewritten by me (DM), because
  1205.  I found it more looking like spaghetti than code. I hope you like the
  1206.  new structure...}
  1207.  
  1208. var oldprocsym:Pprocsym;
  1209.     oldprocinfo:tprocinfo;
  1210.  
  1211.     oldconstsymtable:Psymtable;
  1212.  
  1213.     names:Pstringcontainer;
  1214.  
  1215.     {True if the procedure will be exported.}
  1216.     global:boolean;
  1217.  
  1218.     {True if the procedure is a forward declaration.}
  1219.     was_forward:boolean;
  1220.  
  1221.     {True if the procedure body should be parsed.}
  1222.     body:boolean;
  1223.  
  1224.     oldprefix:string;
  1225.  
  1226. begin
  1227.     oldprocsym:=aktprocsym;
  1228.     oldprefix:=procprefix;
  1229.     oldconstsymtable:=constsymtable;
  1230.     oldprocinfo:=procinfo;
  1231.     procinfo.parent:=@oldprocinfo;
  1232.     codegen_newprocedure;
  1233.  
  1234.     { clear flags }
  1235.     procinfo.flags:=0;
  1236.  
  1237.     { standard frame pointer }
  1238. {***IMPROVED}
  1239.     procinfo.framepointer:=frame_pointer;
  1240. {***}
  1241. {$ifdef GDB}
  1242.     procinfo.funcret_is_valid:=false;
  1243. {$endif GDB}
  1244.     { is this a nested function of a method ? }
  1245.     procinfo._class:=oldprocinfo._class;
  1246.  
  1247.     proc_head;
  1248.  
  1249.     { set return type }
  1250.     procinfo.retdef:=aktprocsym^.definition^.retdef;
  1251.  
  1252.     { pointer to the return value ? }
  1253.     if ret_in_param(procinfo.retdef) then
  1254.         begin
  1255.             procinfo.retoffset:=procinfo.call_offset;
  1256.             if (procinfo.flags and pooperator)<>0 then
  1257.                 opsym^.address:=0;
  1258.             inc(procinfo.call_offset,4);
  1259.         end;
  1260.  
  1261.     { allows to access the parameters of main functions in nested functions }
  1262.     aktprocsym^.definition^.parast^.call_offset := procinfo.call_offset;
  1263.  
  1264.     { parse only a header ? }
  1265.     if not parse_only then
  1266.         begin
  1267.             { EXPORT needs this }
  1268.             new(names,init);
  1269.             names^.doubles:=false;
  1270.             global:=false;
  1271.             body:=true;
  1272.             procinfo.exported:=false;
  1273.             aktprocsym^.definition^.forwarddef:=false;
  1274.  
  1275.             parse_proc_directives(names,global,body);
  1276.  
  1277.             was_forward:=check_identical;
  1278.  
  1279.             {A method must be forward defined (in the object declaration).}
  1280.             if assigned(procinfo._class) and
  1281.               not(assigned(oldprocinfo._class)) and
  1282.              not(was_forward) then
  1283.                 Message(parser_e_header_dont_match_any_member);
  1284.  
  1285.             if not(was_forward) and ((procinfo.flags and
  1286.              pi_is_global)<>0) then
  1287.               Message(parser_e_overloaded_must_be_all_global);
  1288.  
  1289.             { write some informations }
  1290.             Message3(parser_p_procedure_start,aktprocsym^.name,aktprocsym^.definition^.mangledname,
  1291.                      tostr(current_module^.current_inputfile^.line_no));
  1292.  
  1293.             {Not needed. I have added a popstack directive.
  1294.             if procinfo.exported then
  1295.                 aktprocsym^.definition^.options:=aktprocsym^.definition^.
  1296.                  options or poclearstack;}
  1297.  
  1298.             if body then
  1299.                 begin
  1300.                     names^.insert(aktprocsym^.definition^.mangledname);
  1301.                     compile_proc_body(names^,global,
  1302.                      assigned(oldprocinfo._class));
  1303.                     consume(SEMICOLON);
  1304.                 end;
  1305.             names^.done;
  1306.         end
  1307.     else
  1308.      begin
  1309.         if (token=ID) and (pattern='FAR') then
  1310.         Begin
  1311.           Message(parser_w_proc_far_ignored);
  1312.           consume(ID);
  1313.           consume(SEMICOLON);
  1314.         end;
  1315.         aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
  1316.      end;
  1317.     constsymtable:=oldconstsymtable;
  1318.     aktprocsym:=oldprocsym;
  1319.     procprefix:=oldprefix;
  1320.     codegen_doneprocedure;
  1321.     procinfo:=oldprocinfo;
  1322. end;
  1323.  
  1324. end.
  1325.  
  1326. {
  1327.   $Log: psub.pas,v $
  1328.   Revision 1.3.2.4  1998/08/22 10:23:00  florian
  1329.     * quick fix of procedure(...);cdecl;export;, the label was
  1330.       written two times with the same name
  1331.  
  1332.   Revision 1.3.2.3  1998/08/13 17:41:26  florian
  1333.     + some stuff for the PalmOS added
  1334.  
  1335.   Revision 1.3.2.2  1998/08/05 14:07:35  pierre
  1336.     * changed assembler statement so that a stack frame is generated
  1337.       if there are arguments
  1338.  
  1339.   Revision 1.3.2.1  1998/07/10 12:26:35  carl
  1340.     * bugfix with crash on duplivate procedure
  1341.  
  1342.   Revision 1.3  1998/03/30 21:04:00  florian
  1343.     * new version 0.99.5
  1344.     + cdecl id
  1345.  
  1346.   Revision 1.2  1998/03/28 23:09:57  florian
  1347.     * secondin bugfix (m68k and i386)
  1348.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  1349.       secondadd, since everything is done using 32-bit
  1350.     * loading pointer to routines hopefully fixed (m68k)
  1351.     * flags problem with calls to RTL internal routines fixed (still strcmp
  1352.       to fix) (m68k)
  1353.     * #ELSE was still incorrect (didn't take care of the previous level)
  1354.     * problem with filenames in the command line solved
  1355.     * problem with mangledname solved
  1356.     * linking name problem solved (was case insensitive)
  1357.     * double id problem and potential crash solved
  1358.     * stop after first error
  1359.     * and=>test problem removed
  1360.     * correct read for all float types
  1361.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  1362.     * push/pop is now correct optimized (=> mov (%esp),reg)
  1363.  
  1364.   Revision 1.1.1.1  1998/03/25 11:18:14  root
  1365.   * Restored version
  1366.  
  1367.   Revision 1.40  1998/03/18 22:50:11  florian
  1368.     + fstp/fld optimization
  1369.     * routines which contains asm aren't longer optimzed
  1370.     * wrong ifdef TEST_FUNCRET corrected
  1371.     * wrong data generation for array[0..n] of char = '01234'; fixed
  1372.     * bug0097 is fixed partial
  1373.     * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
  1374.       65535)
  1375.  
  1376.   Revision 1.39  1998/03/10 16:27:43  pierre
  1377.     * better line info in stabs debug
  1378.     * symtabletype and lexlevel separated into two fields of tsymtable
  1379.     + ifdef MAKELIB for direct library output, not complete
  1380.     + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
  1381.       working
  1382.     + ifdef TESTFUNCRET for setting func result in underfunction, not
  1383.       working
  1384.  
  1385.   Revision 1.38  1998/03/10 13:23:00  florian
  1386.     * small win32 problems fixed
  1387.  
  1388.   Revision 1.37  1998/03/10 01:17:25  peter
  1389.     * all files have the same header
  1390.     * messages are fully implemented, EXTDEBUG uses Comment()
  1391.     + AG... files for the Assembler generation
  1392.  
  1393.   Revision 1.36  1998/03/09 16:15:31  michael
  1394.   * fixed small typo of daniel
  1395.  
  1396.   Revision 1.35  1998/03/09 16:00:35  daniel
  1397.   Fixed the ;external; procdir for external procedures in .o files.
  1398.  
  1399.   Revision 1.34  1998/03/09 10:40:25  peter
  1400.     * removed warnings for [C] procedures
  1401.  
  1402.   Revision 1.33  1998/03/06 00:52:48  peter
  1403.     * replaced all old messages from errore.msg, only ExtDebug and some
  1404.       Comment() calls are left
  1405.     * fixed options.pas
  1406.  
  1407.   Revision 1.32  1998/03/05 22:43:52  florian
  1408.     * some win32 support stuff added
  1409.  
  1410.   Revision 1.31  1998/03/04 01:35:10  peter
  1411.     * messages for unit-handling and assembler/linker
  1412.     * the compiler compiles without -dGDB, but doesn't work yet
  1413.     + -vh for Hint
  1414.  
  1415.   Revision 1.30  1998/03/02 13:38:50  peter
  1416.     + importlib object
  1417.     * doesn't crash on a systemunit anymore
  1418.     * updated makefile and depend
  1419.  
  1420.   Revision 1.28  1998/02/28 03:55:31  carl
  1421.     * bugfix #101 (parameter name checking for interface/implementation)
  1422.  
  1423.   Revision 1.26  1998/02/27 22:28:00  florian
  1424.     + win_targ unit
  1425.     + support of sections
  1426.     + new asmlists: sections, exports and resource
  1427.  
  1428.   Revision 1.25  1998/02/27 21:24:10  florian
  1429.     * dll support changed (dll name can be also a string contants)
  1430.  
  1431.   Revision 1.24  1998/02/27 09:26:04  daniel
  1432.   * Changed symtable handling so no junk symtable is put on the symtablestack.
  1433.  
  1434.   Revision 1.23  1998/02/22 23:03:31  peter
  1435.     * renamed msource->mainsource and name->unitname
  1436.     * optimized filename handling, filename is not seperate anymore with
  1437.       path+name+ext, this saves stackspace and a lot of fsplit()'s
  1438.     * recompiling of some units in libraries fixed
  1439.     * shared libraries are working again
  1440.     + $LINKLIB <lib> to support automatic linking to libraries
  1441.     + libraries are saved/read from the ppufile, also allows more libraries
  1442.       per ppufile
  1443.  
  1444.   Revision 1.22  1998/02/20 20:32:57  carl
  1445.     - removed a comment
  1446.  
  1447.   Revision 1.21  1998/02/16 12:51:40  michael
  1448.   + Implemented linker object
  1449.  
  1450.   Revision 1.20  1998/02/16 08:43:00  daniel
  1451.   Fixed internproc bug.
  1452.  
  1453.   Revision 1.19  1998/02/13 10:35:30  daniel
  1454.   * Made Motorola version compilable.
  1455.   * Fixed optimizer
  1456.  
  1457.   Revision 1.18  1998/02/12 11:50:31  daniel
  1458.   Yes! Finally! After three retries, my patch!
  1459.  
  1460.   Changes:
  1461.  
  1462.   Complete rewrite of psub.pas.
  1463.   Added support for DLL's.
  1464.   Compiler requires less memory.
  1465.   Platform units for each platform.
  1466.  
  1467.   Revision 1.17  1998/02/02 11:49:15  pierre
  1468.     + warning if function return not set
  1469.  
  1470.   Revision 1.16  1998/02/02 00:55:34  peter
  1471.     * defdatei -> deffile and some german comments to english
  1472.     * search() accepts : as seperater under linux
  1473.     * search for ppc.cfg doesn't open a file (and let it open)
  1474.     * reorganize the reading of parameters/file a bit
  1475.     * all the PPC_ environments are now for all platforms
  1476.  
  1477.   Revision 1.15  1998/02/01 22:41:12  florian
  1478.     * clean up
  1479.     + system.assigned([class])
  1480.     + system.assigned([class of xxxx])
  1481.     * first fixes of as and is-operator
  1482.  
  1483.   Revision 1.14  1998/01/30 11:14:31  michael
  1484.   * Fixed bug that crashed the compiler. (From peters fix)
  1485.  
  1486.   Revision 1.13  1998/01/27 22:02:33  florian
  1487.     * small bug fix to the compiler work, I forgot a not(...):(
  1488.  
  1489.   Revision 1.12  1998/01/25 22:29:03  florian
  1490.     * a lot bug fixes on the DOM
  1491.  
  1492.   Revision 1.11  1998/01/21 02:17:32  carl
  1493.     - moved omitting stack frame stuff for assembler routines to
  1494.       pstatmnt otherwise would cause much problems in assembler blocks
  1495.       with local variables.
  1496.  
  1497.   Revision 1.9  1998/01/16 18:03:18  florian
  1498.     * small bug fixes, some stuff of delphi styled constructores added
  1499.  
  1500.   Revision 1.8  1998/01/12 13:03:33  florian
  1501.     + parsing of class methods implemented
  1502.  
  1503.   Revision 1.7  1998/01/11 17:06:40  carl
  1504.     * bugfix #69 (not 100% compatible with TP) -- see bug bug0073.pp
  1505.  
  1506.   Revision 1.6  1998/01/11 10:54:25  florian
  1507.     + generic library support
  1508.  
  1509.   Revision 1.5  1998/01/11 04:26:49  carl
  1510.     + stackframe checking added for m68k
  1511.     * bugfix of floating point values returns in proc.
  1512.  
  1513.   Revision 1.4  1998/01/09 23:08:33  florian
  1514.     + C++/Delphi styled //-comments
  1515.     * some bugs in Delphi object model fixed
  1516.     + override directive
  1517.  
  1518.   Revision 1.3  1998/01/09 13:39:56  florian
  1519.     * public, protected and private aren't anymore key words
  1520.     + published is equal to public
  1521.  
  1522.   Revision 1.2  1998/01/09 09:10:03  michael
  1523.   + Initial implementation, second try
  1524.  
  1525. }
  1526.